home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / prog.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  5KB  |  284 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.  
  9.     prog.c
  10. */
  11.  
  12. #include "include.h"
  13.  
  14. /*
  15.     use of VS in tagbody:
  16.  
  17.          old_top ->    |  id    |
  18.             | lex0    |
  19.             | lex1    |
  20.             | lex2    |
  21.        tinf_base ->    | tag1    |    where 'bodyi' is the part of tag-body
  22.             | body1    |    that follows the tag 'tagi'.
  23.             |   :    |
  24.                 :        i.e.
  25.             |   :    |    tag-body
  26.             | tagn    |    = (...tag1..........tagn.............)
  27.             | bodyn    |          |        |<- bodyn ->|
  28.          new_top ->    |    |          |                |
  29.                VS              |<-------- body1 -------->|
  30. */
  31.  
  32. Ftagbody(body)
  33. object body;
  34. {
  35.     object *old_top = vs_top;
  36.     object *new_top;
  37.     object *tinf;
  38.     object *tinf_base;
  39.     object *env = lex_env;
  40.     object id = alloc_frame_id();
  41.     object bodysv = body;
  42.     object label;
  43.     enum type item_type;
  44.  
  45.     vs_push(id);
  46.     lex_copy();
  47.     tinf_base = vs_top;
  48.     while (!endp(body)) {
  49.         label = MMcar(body);
  50.         item_type = type_of(label);
  51.         if (item_type == t_symbol || item_type == t_fixnum ||
  52.                 item_type == t_bignum) {
  53.             lex_tag_bind(label, id);
  54.             vs_push(label);
  55.             vs_push(MMcdr(body));
  56.         }
  57.         body = MMcdr(body);
  58.     }
  59.  
  60.     new_top = vs_top;
  61.  
  62.     frs_push(FRS_CATCH, id);
  63.     body = bodysv;
  64.     if (nlj_active) {
  65.         label = cdr(nlj_tag);
  66.         nlj_active = FALSE;
  67.         for(tinf = tinf_base;
  68.             tinf < new_top && !eql(tinf[0],label);
  69.             tinf += 2)
  70.             ;
  71.         if (tinf >= new_top)
  72.             FEerror("Someone tried to RETURN-FROM a TAGBODY.",0);
  73.         body = tinf[1];
  74.     }
  75.     while (body != Cnil) {
  76.         vs_top = new_top;
  77.         item_type = type_of(MMcar(body));
  78.         if (item_type != t_symbol && item_type != t_fixnum &&
  79.             item_type != t_bignum)
  80.             eval(MMcar(body));
  81.         body = MMcdr(body);
  82.     }
  83.     frs_pop();
  84.     lex_env = env;
  85.     vs_base = old_top;
  86.     vs_top = old_top+1;
  87.     vs_base[0] = Cnil;
  88. }
  89.  
  90. Fprog(arg)
  91. object arg;
  92. {
  93.     object *oldlex = lex_env;
  94.     struct bind_temp *start;
  95.     object body;
  96.     bds_ptr old_bds_top = bds_top;
  97.  
  98.     if (endp(arg))
  99.         FEtoo_few_argumentsF(arg);
  100.  
  101.     make_nil_block();
  102.  
  103.     if (nlj_active) {
  104.         nlj_active = FALSE;
  105.         goto END;
  106.     }
  107.  
  108.     start = (struct bind_temp *)vs_top;
  109.     let_var_list(arg->c.c_car);
  110.     body = let_bind(arg->c.c_cdr, start, (struct bind_temp *)vs_top);
  111.     vs_top = (object *)start;
  112.     vs_push(body);
  113.  
  114.     Ftagbody(body);
  115.  
  116. END:
  117.     bds_unwind(old_bds_top);
  118.     frs_pop();
  119.     lex_env = oldlex;
  120. }
  121.  
  122. FprogA(arg)
  123. object arg;
  124. {
  125.     object *oldlex = lex_env;
  126.     object *top;
  127.     struct bind_temp *start;
  128.     object body;
  129.     bds_ptr old_bds_top = bds_top;
  130.  
  131.     if (endp(arg))
  132.         FEtoo_few_argumentsF(arg);
  133.  
  134.     make_nil_block();
  135.  
  136.     if (nlj_active) {
  137.         nlj_active = FALSE;
  138.         goto END;
  139.     }
  140.  
  141.     start = (struct bind_temp *) vs_top;
  142.     let_var_list(arg->c.c_car);
  143.     body = letA_bind(arg->c.c_cdr, start, (struct bind_temp *)vs_top);
  144.     vs_top = (object *)start;
  145.     vs_push(body);
  146.  
  147.     Ftagbody(body);
  148.  
  149. END:
  150.     bds_unwind(old_bds_top);
  151.     frs_pop();
  152.     lex_env = oldlex;
  153. }
  154.  
  155. Fgo(args)
  156. object args;
  157. {
  158.     object lex_tag;
  159.     frame_ptr fr;
  160.     if (endp(args))
  161.         FEtoo_few_argumentsF(args);
  162.     if (!endp(MMcdr(args)))
  163.         FEtoo_many_argumentsF(args);
  164.     lex_tag = lex_tag_sch(MMcar(args));
  165.     if (MMnull(lex_tag))
  166.         FEerror("~S is an undefined tag.", 1, MMcar(args));
  167.     fr = frs_sch(MMcaddr(lex_tag));
  168.     if (fr == NULL)
  169.         FEerror("The tag ~S is missing.", 1, MMcar(args));
  170.     vs_push(MMcons(MMcaddr(lex_tag), MMcar(lex_tag)));
  171.     vs_base = vs_top;
  172.     unwind(fr,vs_top[-1]);
  173.     /*  never reached  */
  174. }
  175.  
  176. Fprogv(args)
  177. object args;
  178. {
  179.     object *top;
  180.     object symbols;
  181.     object values;
  182.     bds_ptr old_bds_top;
  183.     object var;
  184.  
  185.     if (endp(args) || endp(MMcdr(args)))
  186.          FEtoo_few_argumentsF(args);
  187.  
  188.     old_bds_top=bds_top;
  189.  
  190.     top=vs_top;
  191.     eval(MMcar(args));
  192.     vs_top=top;
  193.     symbols=vs_base[0];
  194.     vs_push(symbols);
  195.     eval(MMcadr(args));
  196.     vs_top=top+1;
  197.     values=vs_base[0];
  198.     vs_push(values);
  199.     while (!endp(symbols)) {
  200.         var = MMcar(symbols);
  201.  
  202.         if (type_of(var)!=t_symbol) not_a_symbol(var);
  203.         if ((enum stype)var->s.s_stype == stp_constant)
  204.             FEerror("Cannot bind the constant ~S.", 1, var);
  205.  
  206.         if (endp(values)) {
  207.             bds_bind(var, OBJNULL);
  208.         } else {
  209.             bds_bind(var, MMcar(values));
  210.             values=MMcdr(values);
  211.         }
  212.         symbols=MMcdr(symbols);
  213.     }
  214.  
  215.     Fprogn(MMcddr(args));
  216.  
  217.     bds_unwind(old_bds_top);
  218. }
  219.  
  220. Fprogn(body)
  221. object body;
  222. {
  223.     if(endp(body)) {
  224.         vs_base=vs_top;
  225.         vs_push(Cnil);
  226.     } else {
  227.         object *top=vs_top;
  228.         do {
  229.             vs_top=top;
  230.             eval(MMcar(body));
  231.             body=MMcdr(body);
  232.         } while (!endp(body));
  233.     }
  234. }
  235.  
  236. Fprog1(arg)
  237. object arg;
  238. {
  239.     object *top = vs_top;
  240.  
  241.     if(endp(arg))
  242.         FEtoo_few_argumentsF(arg);
  243.     eval(MMcar(arg));
  244.     vs_top = top;
  245.     vs_push(vs_base[0]);
  246.     for(arg = MMcdr(arg);  !endp(arg);  vs_top = top+1, arg = MMcdr(arg))
  247.         eval(MMcar(arg));
  248.     vs_base = top;
  249.     vs_top = top + 1;
  250. }
  251.  
  252. Fprog2(arg)
  253. object arg;
  254. {
  255.     object *top = vs_top;
  256.  
  257.     if(endp(arg) || endp(MMcdr(arg)))
  258.         FEtoo_few_argumentsF(arg);
  259.     eval(MMcar(arg));
  260.     vs_top = top;
  261.     arg = MMcdr(arg);
  262.     eval(MMcar(arg));
  263.     vs_top = top;
  264.     vs_push(vs_base[0]);
  265.     for(arg = MMcdr(arg);  !endp(arg);  vs_top = top+1, arg = MMcdr(arg))
  266.         eval(MMcar(arg));
  267.     vs_base = top;
  268.     vs_top = top+1;
  269. }
  270.  
  271. init_prog()
  272. {
  273.     make_special_form("TAGBODY", Ftagbody);
  274.     make_special_form("PROG", Fprog);
  275.     make_special_form("PROG*", FprogA);
  276.     make_special_form("GO", Fgo);
  277.  
  278.     make_special_form("PROGV", Fprogv);
  279.  
  280.     make_special_form("PROGN",Fprogn);
  281.     make_special_form("PROG1",Fprog1);
  282.     make_special_form("PROG2",Fprog2);
  283. }
  284.